\ 4tH Preprocessor - Copyright 2009, 2012 J.L. Bezemer
\ You can redistribute this file and/or modify it under
\ the terms of the GNU General Public License

79 constant RMARGIN                    \ for PRINT

include lib/parsname.4th               \ for PARSE-NAME
include lib/print.4th                  \ for PRINT
include lib/row.4th                    \ for ROW
include lib/ncoding.4th                \ for NELL, N!, N@
include lib/stack.4th                  \ for >A, A>
include lib/stmstack.4th               \ for >S, S>
include lib/ctos.4th                   \ for C>S

s" ;"   sconstant ";"                  \ string constant ;
s| S" | sconstant "S""                 \ string constant S"

 64 constant c/l                       \ chars per line of a standard block
 32 constant #case                     \ depth of CASE stack
128 constant #macro                    \ maximum number of macros
256 constant %macro                    \ average size of a macro
  4 constant #var                      \ maximum number of variables
128 constant /var                      \ maximum size of a variable
 32 constant #include                  \ maximum number of include files
 32 constant /name                     \ maximum length of name in ANS-Forth

    256 constant /dir4th               \ maximum size of DIR4TH path
/dir4th string dir4th                  \ allocate DIR4TH buffer
      0 value cursor                   \ cursor position

/name string struct-name               \ name of structure
                                       \ calculate size of macro buffer
#macro %macro * constant /macro-buffer
/macro-buffer buffer: macro-buffer     \ allocate macro buffer
                                       \ allocate variable buffer
#var /var * buffer: ppvar does> swap /var * + ;

struct                                 \ structure for macro
  /name +field name                    \ name of the macro
  nell  +field buf-addr                \ start in macro buffer
end-struct /macro                      \ size of macro structure
                                       \ allocate macro array
#macro /macro * buffer: macro does> swap /macro * + ;

struct                                 \ structure for include files
   128 +field sourcename               \ name of the source file
  /tib +field terminalinput            \ save contents of TIB
  nell +field in                       \ save >IN
  nell +field position                 \ save current file position
  nell +field read                     \ save file reading method
end-struct /include                    \ size of include structure
                                       \ allocate include array
#include /include * buffer: includes does> swap /include * + ;

#case array case-stack                 \ CASE control stack
stack-cells 2 * array macro-stack    \ macro context stack

defer macro?                           \ forward declaration
defer readline                         \ primitive to read file
variable tob                           \ top of buffer
variable macro#                        \ number of defined macros
variable include#                      \ level of included files
false value state?                     \ are we defining a macro
                                       \ the reading primitives
: read-seq refill ;                    ( -- f)
: read-blk c/l tib over accept = 0 dup >in ! tib c/l chars + c! ;

create mode                            \ how to read the file
  ," 4th" ' read-seq ,
  ," seq" ' read-seq ,
  ," .fs" ' read-seq ,
  ," frt" ' read-seq ,
  ," fth" ' read-seq ,
  ," scr" ' read-blk ,
  ," blk" ' read-blk ,
  NULL ,
does>
  >r 2dup dup 3 - /string r> 2 string-key row 
  if cell+ @c else drop ['] read-seq then >r 2drop r> dup is readline 
;                                      \ add a word to macro space
 
: >macro                               ( a n --)
  tob @ over over over >r + macro-buffer /macro-buffer chars + < 0=
  abort" Macro space exhausted" place r> 1+ tob +!
;                                      \ check if it fits in macro space
                                       \ a few helper words
: n>s dup abs <# #s sign #> ;          ( n1 -- a n2)
: cursor@ >in @ to cursor ;            \ save cursor of TIB
: eol? >in @ cursor = dup if nl then ; \ end of line? if so, newline
: +macro -1 tob +! >macro ;            ( a n --)
: .char state? if c>s +macro else show then ;
: ?char dup bl < if drop else .char then ;
: (+write) state? if +macro else (print) then ;
: +write dup if bl .char (+write) else 2drop then ;
: write state? if >macro else print-word then ;
: (delimiter) >r write r@ parse +write r> ?char ;
: delimiter| parse 2drop ;             ( c --)
: EOL| 2drop 0 delimiter| ;            \ delete until end of line
: )| 2drop [char] ) delimiter| ;       \ delete until )
                                       \ parse and discard comments
create comment?
  ," \" ' EOL| ,
  ," (" ' )|   ,
  NULL ,
does> 2 string-key row dup >r if cell+ @c execute else drop then r> ;
                                       \ is a macro defined?
: defined?                             ( a n1 -- n2 a n1 f)
  2>r macro# @ 0                       \ find macro and print it, set flag
  begin over over > while dup macro -> name count 2r@ compare while 1+ repeat
  tuck > 2r> rot
;
                                       \ get next token
: read-token                           ( -- a n)
  begin                                \ read next token
    parse-name dup 0=                  \ if it has zero length
  while                                \ try to read the next line
    2drop readline 0= abort" Unexpected end of file"
  repeat                               \ try to parse again
;
                                       ( -- a n)
: next-token begin read-token comment? 0= until ;
: alien? 2drop next-token 2dup number error? swap 0< ;
: >context macro-stack >a macro-stack >a ;
: context> macro-stack a> macro-stack a> ;
: >p >s s.error abort" String stack full" ;
: p> s> s.error abort" String stack empty" ;
: n> p> number error? abort" Bad number" ;
: >n n>s >p ;                          ( n --)
: +ppvar 1+ chars + count ;
: ?abort if >r begin 2dup +ppvar dup while 2nip repeat 2drop r> then ;
: ppvar! >r dup /var 1- > abort" String too long" r> ppvar place ;
: var! next-token rot ppvar! ;         ( n --)
: var> p> rot ppvar! ;
: >var ppvar count >p ;
: .var ppvar count print-word ;        ( n --)
: parse-var! >r +ppvar 2dup 0= abort" Missing string" c@ parse r> ppvar! ;
                                       \ PP variable words
: @1@ 0 var! ;                         \ parse and save a variable
: @2@ 1 var! ;
: @3@ 2 var! ;
: @4@ 3 var! ;
: #1# 0 .var ;                         \ print a variable
: #2# 1 .var ;
: #3# 2 .var ;
: #4# 3 .var ;
: >1> 0 >var ;                         \ put a variable on the string stack
: >2> 1 >var ;
: >3> 2 >var ;
: >4> 3 >var ;
: <1< 0 var> ;                         \ get a variable on the string stack
: <2< 1 var> ;
: <3< 2 var> ;
: <4< 3 var> ;
: $1$ 0 parse-var! ;                   \ custom parse and save in variable
: $2$ 1 parse-var! ;
: $3$ 2 parse-var! ;
: $4$ 3 parse-var! ;
: >#> next-token >p ;                  \ phoney variables
: <#< p> 2drop ;
: |#| p> (print) ;
: >>> +ppvar 2dup dup 0= abort" Missing string" >p ;
: @if n> dup 0= ?abort >n ;
: @add n> n> + >n ;
: @mul n> n> * >n ;
: @divrm n> n> swap /mod >n >n ;
: @else n> dup ?abort 0= >n ;
: @exist p> defined? >r 2drop drop r> >n ;
: @minus n> negate >n ;
: @eval >context p> macro? context> ;
: @sign n> dup 0< negate swap 0> + >n ;
: @match p> p> compare >n ;
: @until @match @if ;
: @while @match @else ;
                                       \ how to treat a PP4tH variable
create ppvar?
  ," @1@" ' @1@ ,
  ," @2@" ' @2@ ,
  ," @3@" ' @3@ ,
  ," @4@" ' @4@ ,
  ," #1#" ' #1# ,
  ," #2#" ' #2# ,
  ," #3#" ' #3# ,
  ," #4#" ' #4# ,
  ," >1>" ' >1> ,
  ," >2>" ' >2> ,
  ," >3>" ' >3> ,
  ," >4>" ' >4> ,
  ," <1<" ' <1< ,
  ," <2<" ' <2< ,
  ," <3<" ' <3< ,
  ," <4<" ' <4< ,
  ," $1$" ' $1$ ,
  ," $2$" ' $2$ ,
  ," $3$" ' $3$ ,
  ," $4$" ' $4$ ,
  ," >#>" ' >#> ,
  ," <#<" ' <#< ,
  ," |#|" ' |#| ,
  ," >>>" ' >>> ,
  ," @drop"   ' <#< ,
  ," @if"     ' @if ,
  ," @add"    ' @add ,
  ," @mul"    ' @mul ,
  ," @else"   ' @else ,
  ," @ifnot"  ' @else ,
  ," @exist"  ' @exist ,
  ," @divrm"  ' @divrm ,
  ," @minus"  ' @minus ,
  ," @eval"   ' @eval ,
  ," @sign"   ' @sign ,
  ," @match"  ' @match ,
  ," @while"  ' @while ,
  ," @until"  ' @until ,
  NULL ,                               \ search and execute PP4tH variable
                                       \ prints out an entire macro
:noname                                ( a n --)
  defined?                             \ is the macro defined?
  if
    2drop macro -> buf-addr n@ count   \ if so, get its address
    begin
      dup                              \ print it out until null string
    while
      ppvar? 2 string-key row          \ save context to preserve stack space
      if cell+ @c execute else drop 2dup >context recurse context> then +ppvar
    repeat drop
  else
    print-word                         \ if not a macro, print word
  then drop
; is macro?                            \ horribly long word, but efficient
                                       \ save filename in NEW record
: filename!                            ( c -- a n)
  dup bl = if drop next-token else parse then 2dup
  include# @ dup #include < 0= abort" Include file nested too deep"
  includes >r mode r@ -> read n! r> -> sourcename place 1 include# +!
;                                      \ abort if includes nested too deep
                                       \ save position info in prev. record
: position!                            ( h -- h)
  include# @ 1- 1- includes >r         \ get pointer to PREVIOUS record
  dup tell r@ -> position n! tib r@ -> terminalinput /tib cmove
  >in @ r> -> in n! (error) to cursor  \ save contents of TIB and >IN
;                                      \ and increment include pointer
                                       \ open an INCLUDE file 
: open-include                         ( a n -- h)
  2dup input open error?               \ try to open it normally
  if                                   \ did that work?
    s" DIR4TH" environ@ dir4th place   \ initialize DIR4TH buffer
    drop dir4th +place                 \ if not, add DIR4TH path
    dir4th count input open error?     \ and try again
    abort" Cannot open include file"   \ abort on error
  else                                 \ if it did work
    >r 2drop r>                        \ get rid of the filename copy
  then dup use                         \ use the open file immediately
;
                                       \ process an INCLUDE or [NEEDS
: >include                             ( hi ho c -- hi ho)
  state? abort" Directive not allowed here"
  filename! 2>r swap position! close 2r> open-include swap 
  readline 0= abort" Cannot read include file"
;                                      \ close previous file and open include
                                       \ behavior of several delimiters
: (EOL) 0 (delimiter) ;                ( a n --)
: (") [char] " (delimiter) ;           ( a n --)
: (|) [char] | (delimiter) ;           ( a n --)
: ()) [char] ) (delimiter) ;           ( a n --)
                                       \ behavior of ;
: (;) state? if dup xor >macro false to state? else print-word then ;
: (`) state? if 2drop [char] ` parse >macro else print-word then ;
: .INIT next-token 2dup write 2dup write ;
: .REDO s" :REDO" write write ;        ( a n --)
: .NUMBER 2swap "S"" write (+write) [char] " .char write ;
: (WHITE) write next-token +write ;    \ resolve whitespace behavior
: (INCLUDE) 2drop bl >include ;        \ resolve INCLUDE behavior
: (NEEDS) 2drop [char] ] >include ;    \ resolve [NEEDS behavior
: (CHAR) 2drop read-token drop c@ n>s write ;
: (S\") 2drop s| S"| (") s" S>ANS" write ;
: (OF) 2drop s" OVER" write s" =" write s" IF" write s" DROP" write ;
: (ACTION-OF) 2drop s" [']" write next-token write s" DEFER@" write ;
: (SYNONYM) 2drop s" AKA" write next-token next-token write write ;
: (STRUCT) 2drop s" STRUCT" write next-token struct-name place ;
: (END-STRUCT) 2drop s" END-STRUCT" write struct-name count write ;
: (FFIELD:) 2drop s" FLOAT" write s" +FIELD" write ;
: (FVARIABLE) 2drop s" FLOAT" write s" ARRAY" write ;
: (2VARIABLE) 2drop s" 2" write s" ARRAY" write ;
: (2CONSTANT) (2VARIABLE) .INIT s" 2!" write .REDO s" 2@" write ";" write ;
: (FCONSTANT) (FVARIABLE) .INIT s" F!" write .REDO s" F@" write ";" write ;
: (D%) alien? or   if s" S>DOUBLE" .NUMBER else write s" U>D" write then ;
: (F%) alien? drop if s" S>FLOAT"  .NUMBER else write s" S>F" write then ;
: ([BINARY]) write 2 base ! ;          \ set radix to binary
: ([OCTAL]) write octal ;              \ set radix to octal
: ([DECIMAL]) write decimal ;          \ set radix to decimal
: ([HEX]) write hex ;                  \ set radix to hexadecimal
                                       \ replace OF with OVER = IF DROP
: (CASE)                               \ initialize control stack
  2drop case-stack adepth #case 1- = abort" Nesting too deep"
  0 case-stack >a                      \ abort when stack overflows
;                                      \ put counter on stack

: (ENDOF)                              \ replace ENDOF with ELSE
  2drop s" ELSE" write                 \ abort if case-stack empty
  case-stack adepth 0= abort" Missing CASE"
  case-stack a> 1+ case-stack >a       \ increment top of case-stack
;
                                       \ replace ENDCASE with DROP
: (ENDCASE)                            \ abort if case-stack empty
  2drop s" DROP" write                 \ write as many THENs as ELSEs
  case-stack adepth 0= abort" Missing CASE"
  case-stack a> 0 ?DO s" THEN" write LOOP
;                                      \ remove top of case-stack
                                       \ undefine a macro
: (SCRAP:)                             \ check if macro was defined
  2drop state? abort" Directive not allowed here"
  next-token defined? 0= abort" Undefined macro"
  2drop macro# @ 1- over over <        \ move top macro if required
  if macro swap macro /macro cmove else drop drop then -1 macro# +!
;                                      \ decrement number of macros
                                       \ resolve behavior :MACRO keyword
: (:MACRO)                             \ forget the keyword and check
  2drop state? abort" Unexpected macro"
  macro# @ #macro = abort" Too many macros"
  next-token defined? abort" Duplicate macro"
  rot dup >r macro -> name place       \ save the macro name
  tob @ r> macro -> buf-addr n!        \ save the current macro buffer address
  1 macro# +! true to state?           \ increment number of macros and set 
;                                      \ defining state accordingly
                                       \ keywords with associated behaviors
create keyword
  ," `"               ' (`) ,
  ," \"               ' EOL| ,
  ," ("               ' )| ,
  ," #!"              ' (EOL) ,
  ,| ,"|              ' (") ,
  ," ,|"              ' (|) ,
  ,| ."|              ' (") ,
  ," .("              ' ()) ,
  ," .|"              ' (|) ,
  ,| S"|              ' (") ,
  ," S|"              ' (|) ,
  ,| S\"|             ' (S\") ,
  ," CHAR"            ' (CHAR) ,
  ," @GOTO"           ' (EOL) ,
  ," [NEEDS"          ' (NEEDS) ,
  ,| ABORT"|          ' (") ,
  ," [CHAR]"          ' (CHAR) ,
  ," INCLUDE"         ' (INCLUDE) ,
  ," [DEFINED]"       ' (WHITE) ,
  ," [UNDEFINED]"     ' (WHITE) ,
  ," :MACRO"          ' (:MACRO) ,
  ," SCRAP:"          ' (SCRAP:) ,
  ," ;"               ' (;) ,
  ," F%"              ' (F%) ,
  ," D%"              ' (D%) ,
  ," CASE"            ' (CASE) ,
  ," OF"              ' (OF) ,
  ," ENDOF"           ' (ENDOF) ,
  ," ENDCASE"         ' (ENDCASE) ,
  ," BEGIN-STRUCTURE" ' (STRUCT) ,
  ," END-STRUCTURE"   ' (END-STRUCT) ,
  ," FFIELD:"         ' (FFIELD:) ,
  ," FVARIABLE"       ' (FVARIABLE) ,
  ," FCONSTANT"       ' (FCONSTANT) ,
  ," 2VARIABLE"       ' (2VARIABLE) ,
  ," 2CONSTANT"       ' (2CONSTANT) ,
  ," ACTION-OF"       ' (ACTION-OF) ,
  ," SYNONYM"         ' (SYNONYM) ,
  ," [BINARY]"        ' ([BINARY]) ,
  ," [OCTAL]"         ' ([OCTAL]) ,
  ," [DECIMAL]"       ' ([DECIMAL]) ,
  ," [HEX]"           ' ([HEX]) ,
  NULL ,
does>                                  \ standard behavior of keyword
  2 string-key row
  if cell+ @c execute else drop state? if >macro else macro? then then
;
                                       \ prerequisites of CONVERT.4TH
: Read-file                            ( h1 -- h2 f)
  readline dup 0=                      \ get a line
  if                                   \ if we didn't get it..
    drop include# -1 over +! @ dup     \ decrement the include stack
    if                                 \ if we're not at the original source
      1- includes >r swap close        \ get the previous include file
      r@ -> sourcename count open-include
      r@ -> position n@ over seek abort" Seek failed"
      r@ -> terminalinput tib /tib cmove
      r@ -> in n@ >in !                \ open it and restore everything
      r> -> read n@ is readline        \ initialize required reading method
      swap true                        \ signal we're ready for business
    then                               \ let CONVERT.4TH handle the rest
  then
;

: PreProcess                           \ initialize all variables
  macro-buffer tob ! 0 macro# ! 1 include# ! s.clear 1 args mode
  0 includes dup >r -> read n! r> -> sourcename place
  case-stack stack macro-stack stack   \ initialize stacks
;                                      \ and the include file entry
                                       \ of the original source file
: Usage abort" Usage: pp4th infile outfile" ;
: PostProcess case-stack adepth abort" Unmatched CASE" ;

: Process
  begin
    cursor@ parse-name dup
    if ['] keyword catch abort" Internal error" else 2drop then eol?
  until
;

include lib/convert.4th